home *** CD-ROM | disk | FTP | other *** search
/ Light ROM 1 / LIGHT-ROM 1 (Amiga Library Services)(1994).iso / ffdisks / d963.lha / SIOD / scm / merge.scm < prev    next >
Text File  |  1993-05-08  |  4KB  |  60 lines
  1. ; list merge sort
  2.  
  3. (define (sort! x test)      ; si utilizzano le regole di visibilita` 
  4.                             ; per il test che non viene passato alle 
  5.                             ; procedure interne.
  6.         (define (m-s x y)     ; procedura iterativa per la fusione 
  7.                               ; distruttiva di due liste.
  8.                 (define res (list 'dummy))  ; variabile su cui viene 
  9.                                             ; costruita la lista risultato
  10.                                             ; e` inizializzato ad una lista
  11.                                             ; contenente un elemento 
  12.                                             ; fittizio in modo da poter 
  13.                                             ; usare direttamente set-cdr!.
  14.                 (do ((ptr res (cdr ptr))  ; ciclo do principale.
  15.                                           ; la variabile ptr e` usata come
  16.                                           ; puntatore per scorrere la lista
  17.                                           ; risultato.
  18.                      (done #f))   ; flag per terminare il ciclo.
  19.                     (done (cdr res))  ; al termine restituisce il cdr 
  20.                                       ; del risultato.
  21.                     (cond ((null? x) (set-cdr! ptr y) ; se la prima lista e` 
  22.                                                       ; terminata, appende la
  23.                                                       ; seconda al risultato
  24.                                                       ; e termina il ciclo do.
  25.                                      (set! done #t))
  26.                           ((null? y) (set-cdr! ptr x) ; se la seconda lista e` 
  27.                                                       ; terminata, appende la
  28.                                                       ; prima al risultato
  29.                                                       ; e termina il ciclo do.
  30.                                      (set! done #t))
  31.                           ((test (car x) (car y)) ; se il car della prima lista
  32.                                                   ; e` minore di quello della
  33.                                                   ; seconda lo aggiunge al
  34.                                                   ; risultato.
  35.                            (set-cdr! ptr x) 
  36.                            (set! x (cdr x)))
  37.                           (else (set-cdr! ptr y) ; altrimenti aggiunge il car
  38.                                                  ; del secondo.
  39.                                 (set! y (cdr y))))))                     
  40.         (define (mer-so x) ; procedura ricorsiva che suddivide la lista da
  41.                            ; ordinare in sottoliste rispettando l'eventuale
  42.                            ; ordine gia` presente.
  43.                 (if (or (null? x) (null? (cdr x))) 
  44.                     x
  45.                     (if (test (car x) (cadr x))
  46.                         (m-s x
  47.                          (mer-so (do ((ptr (cdr x) (cdr ptr))
  48.                                       (y (cddr x) (cdr y)))
  49.                                      ((or (null? y)
  50.                                           (test (car y) (car ptr))) 
  51.                                       (set-cdr! ptr nil) y))))
  52.                         (m-s (reverse! x)
  53.                               (mer-so (do ((ptr (cdr x) (cdr ptr))
  54.                                            (y (cddr x) (cdr y)))
  55.                                           ((or (null? y)
  56.                                                (test (car ptr) (car y))) 
  57.                                            (set-cdr! ptr nil) y)))))))
  58.         (mer-so x))
  59.  
  60.